pkg <- c("knitr", "lme4", "psych", "EGAnet", "tidymodels", "vip", "qgraph", "RColorBrewer", "lubridate", "broom", "broom.mixed", "plyr", "tidyverse")
if(any(!pkg %in% rownames(installed.packages()))){
pkg <- pkg[!pkg %in% rownames(installed.packages())]
lapply(pkg, install.packages)
}
library(knitr) # rmarkdown
library(lme4) # estimate mlms## Loading required package: Matrix
library(psych) # psychometrics, descriptives, structural models, and more
library(EGAnet) # exploratory graph analysis## [1;m[4;m
## EGAnet (version 1.1.0)[0m[0m
## For help getting started, type browseVignettes("EGAnet")
##
## For bugs and errors, submit an issue to <https://github.com/hfgolino/EGAnet/issues>
library(RColorBrewer)
library(vip)##
## Attaching package: 'vip'
## The following object is masked from 'package:utils':
##
## vi
library(qgraph)
library(lubridate)##
## Attaching package: 'lubridate'
## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, union
library(broom)
library(broom.mixed)
library(plyr) # data wrangling
library(tidyverse) # data wrangling, cleaning, and more## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──
## ✔ ggplot2 3.3.6 ✔ purrr 0.3.4
## ✔ tibble 3.1.7 ✔ dplyr 1.0.9
## ✔ tidyr 1.2.0 ✔ stringr 1.4.0
## ✔ readr 2.1.2 ✔ forcats 0.5.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ ggplot2::%+%() masks psych::%+%()
## ✖ ggplot2::alpha() masks psych::alpha()
## ✖ dplyr::arrange() masks plyr::arrange()
## ✖ lubridate::as.difftime() masks base::as.difftime()
## ✖ purrr::compact() masks plyr::compact()
## ✖ dplyr::count() masks plyr::count()
## ✖ lubridate::date() masks base::date()
## ✖ tidyr::expand() masks Matrix::expand()
## ✖ dplyr::failwith() masks plyr::failwith()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::id() masks plyr::id()
## ✖ lubridate::intersect() masks base::intersect()
## ✖ dplyr::lag() masks stats::lag()
## ✖ dplyr::mutate() masks plyr::mutate()
## ✖ tidyr::pack() masks Matrix::pack()
## ✖ dplyr::rename() masks plyr::rename()
## ✖ lubridate::setdiff() masks base::setdiff()
## ✖ dplyr::summarise() masks plyr::summarise()
## ✖ dplyr::summarize() masks plyr::summarize()
## ✖ lubridate::union() masks base::union()
## ✖ tidyr::unpack() masks Matrix::unpack()
library(tidymodels) # framework for estimating ML and other models## ── Attaching packages ────────────────────────────────────── tidymodels 0.2.0 ──
## ✔ dials 1.0.0 ✔ rsample 1.0.0
## ✔ infer 1.0.2 ✔ tune 0.2.0
## ✔ modeldata 0.1.1 ✔ workflows 0.2.6
## ✔ parsnip 1.0.0 ✔ workflowsets 0.2.1
## ✔ recipes 0.2.0 ✔ yardstick 1.0.0
## ── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ──
## ✖ ggplot2::%+%() masks psych::%+%()
## ✖ scales::alpha() masks ggplot2::alpha(), psych::alpha()
## ✖ dplyr::arrange() masks plyr::arrange()
## ✖ purrr::compact() masks plyr::compact()
## ✖ dplyr::count() masks plyr::count()
## ✖ scales::discard() masks purrr::discard()
## ✖ tidyr::expand() masks Matrix::expand()
## ✖ dplyr::failwith() masks plyr::failwith()
## ✖ dplyr::filter() masks stats::filter()
## ✖ recipes::fixed() masks stringr::fixed()
## ✖ dplyr::id() masks plyr::id()
## ✖ dplyr::lag() masks stats::lag()
## ✖ dplyr::mutate() masks plyr::mutate()
## ✖ tidyr::pack() masks Matrix::pack()
## ✖ dplyr::rename() masks plyr::rename()
## ✖ yardstick::spec() masks readr::spec()
## ✖ recipes::step() masks stats::step()
## ✖ dplyr::summarise() masks plyr::summarise()
## ✖ dplyr::summarize() masks plyr::summarize()
## ✖ tidyr::unpack() masks Matrix::unpack()
## ✖ recipes::update() masks Matrix::update(), stats::update()
## • Dig deeper into tidy modeling with R at https://www.tmwr.org
wd <- "https://github.com/emoriebeck"dat <- read_csv(url(sprintf("%s/ESM-structure/blob/main/02-data/02-facet-wide/02-imputed/02-participant-data/csv/221.csv?raw=true", wd))) %>%
separate(Full_Date, c("date", "time"), sep = "[ ]") %>%
mutate(day = as.numeric(mapvalues(date, unique(date), 1:length(unique(date))))) %>%
group_by(day) %>%
mutate(beep = 1:n()) %>%
ungroup() %>%
filter(beep <=4)## Rows: 261 Columns: 17
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (1): Full_Date
## dbl (16): agreeableness_Compassion, agreeableness_Respectfulness, agreeablen...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
dat <- dat %>%
full_join(
crossing(
day = unique(dat$day)
, beep = 1:6
)
) %>%
arrange(day, beep)## Joining, by = c("day", "beep")
dat <- dat %>%
mutate_at(vars(-date, -time, -all_beeps, -day, -beep), lst(lag = lag))
# how many rows without lags?
dat %>%
select(-contains("lag")) %>%
drop_na()# how many rows with lags
dat %>%
select(-date, -time, -all_beeps) %>%
drop_na()sd(dat$agreeableness_Compassion, na.rm = T)## [1] 1.128466
# the tidy way
dat %>%
select(-contains("lag"), -date, -time, -all_beeps, -day, -beep) %>%
summarize_all(sd, na.rm = T) %>%
pivot_longer(
cols = everything()
, names_to = "var"
, values_to = "sd"
)# base R
sapply(
dat %>%
select(-contains("lag"), -date, -time, -all_beeps, -day, -beep)
, function(x) sd(x, na.rm = T)
)## agreeableness_Compassion agreeableness_Respectfulness
## 1.1284663 0.9935696
## agreeableness_Trust conscientiousness_Organization
## 0.9465205 1.2037256
## conscientiousness_Productiveness conscientiousness_Responsibility
## 1.2332386 1.2143000
## extraversion_Assertiveness extraversion_Energy.Level
## 1.2590248 1.1948333
## extraversion_Sociability neuroticism_Anxiety
## 1.2560469 0.9712506
## neuroticism_Depression neuroticism_Emotional.Volatility
## 0.8784962 1.1528547
## openness_Aesthetic.Sensitivity openness_Creative.Imagination
## 1.1051526 1.0645676
## openness_Intellectual.Curiosity
## 1.0484114
mssd(dat$agreeableness_Compassion)## [1] 0.8981203
# the tidy way
dat %>%
select(-contains("lag"), -date, -time, -all_beeps, -day, -beep) %>%
summarize_all(mssd) %>%
pivot_longer(
cols = everything()
, names_to = "var"
, values_to = "mssd"
)# base R
sapply(
dat %>%
select(-contains("lag"), -date, -time, -all_beeps, -day, -beep)
, mssd
)## agreeableness_Compassion agreeableness_Respectfulness
## 0.8981203 0.8653933
## agreeableness_Trust conscientiousness_Organization
## 0.6080334 1.6481133
## conscientiousness_Productiveness conscientiousness_Responsibility
## 1.9799844 1.3155733
## extraversion_Assertiveness extraversion_Energy.Level
## 1.1916452 1.0303352
## extraversion_Sociability neuroticism_Anxiety
## 1.5822683 0.5613855
## neuroticism_Depression neuroticism_Emotional.Volatility
## 0.5373800 1.0765382
## openness_Aesthetic.Sensitivity openness_Creative.Imagination
## 1.1491743 1.1249584
## openness_Intellectual.Curiosity
## 0.6683865
cor(dat$agreeableness_Compassion, dat$agreeableness_Compassion_lag, use = "pairwise")## [1] 0.2950876
# the tidy way
dat %>%
select(-contains("lag")) %>%
pivot_longer(
cols = c(-date, -time, -all_beeps, -day, -beep)
, names_to = "var"
, values_to = "value"
) %>%
group_by(var) %>%
summarize(ar1 = cor(value, lag(value), use = "pairwise"))dat %>%
select(-contains("lag")) %>%
pivot_longer(
cols = c(-date, -time, -all_beeps, -day, -beep)
, names_to = "var"
, values_to = "value"
) %>%
group_by(var) %>%
summarize(
sd = sd(value, na.rm = T)
, mssd = mssd(value)
, ar1 = cor(value, lag(value), use = "pairwise")
)First, we need to load the data and do some feature engineering
load(url(sprintf("%s/behavior-prediction/blob/main/04-data/02-model-data/216_prcrst_psychological_BFI-2_no%%20time.RData?raw=true", wd)))
ddtime <- d %>%
select(Full_Date) %>%
mutate(Full_Date = ymd_hm(Full_Date)
, wkday = wday(Full_Date, label = T)
, Hour = hour(Full_Date)
, Mon = ifelse(wkday == "Mon", 1, 0)
, Tue = ifelse(wkday == "Tue", 1, 0)
, Wed = ifelse(wkday == "Wed", 1, 0)
, Thu = ifelse(wkday == "Thu", 1, 0)
, Fri = ifelse(wkday == "Fri", 1, 0)
, Sat = ifelse(wkday == "Sat", 1, 0)
, Sun = ifelse(wkday == "Sun", 1, 0)
, morning = ifelse(Hour >= 5 & Hour < 11, 1, 0)
, midday = ifelse(Hour >= 11 & Hour < 17, 1, 0)
, evening = ifelse(Hour >= 5 & Hour < 22, 1, 0)) %>%
## sequential time differences
mutate(tdif = as.numeric(difftime(Full_Date, lag(Full_Date), units = "hours"))) %>%
filter(is.na(tdif) | tdif > 1) %>%
mutate(tdif = as.numeric(difftime(Full_Date, lag(Full_Date), units = "hours"))
, tdif = ifelse(is.na(tdif), 0, tdif)
, cumsumT = cumsum(tdif)) %>%
## timing variables
mutate(linear = as.numeric(scale(cumsumT))
, quad = linear^2
, cub = linear^3
, sin1p = sin(((2*pi)/24)*cumsumT)
, sin2p = sin(((2*pi)/12)*cumsumT)
, cos1p = cos(((2*pi)/24)*cumsumT)
, cos2p = cos(((2*pi)/12)*cumsumT)
) %>%
## keep key variables and reshape
select(Full_Date, Mon:evening, linear:cos2p)
dummy_vars <- c("o_value", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"
, "morning", "midday", "evening")
d <- d %>%
mutate(Full_Date = ymd_hm(Full_Date)) %>%
full_join(dtime) %>%
arrange(Full_Date) %>%
select(-Full_Date) %>%
mutate_at(vars(dummy_vars), factor) %>%
filter(complete.cases(.)); d## Joining, by = "Full_Date"
## Note: Using an external vector in selections is ambiguous. ℹ Use
## `all_of(dummy_vars)` instead of `dummy_vars` to silence this message. ℹ See
## <https://tidyselect.r-lib.org/reference/faq-external-vector.html>. This message
## is displayed once per session.
d_split <- initial_time_split(d, prop = 0.75); d_split## <Training/Testing/Total>
## <72/25/97>
d_train <- training(d_split); d_traind_test <- testing(d_split); d_test# set up the data and formula
time_vars <- c("cos1p", "cos2p", "cub", "linear", "quad", "sin1p", "sin2p")
mod_recipe <- recipe(
o_value ~ .
, data = d_train
) %>%
step_normalize(all_numeric(), -one_of(time_vars)) %>%
step_dummy(one_of(dummy_vars), -all_outcomes()) %>%
step_zv(all_numeric()) %>%
step_nzv(all_nominal(), unique_cut = 35); mod_recipe## Recipe
##
## Inputs:
##
## role #variables
## outcome 1
## predictor 32
##
## Operations:
##
## Centering and scaling for all_numeric(), -one_of(time_vars)
## Dummy variables from one_of(dummy_vars), -all_outcomes()
## Zero variance filter on all_numeric()
## Sparse, unbalanced variable filter on all_nominal()
# set up the model specifications
tune_spec <-
logistic_reg(
penalty = tune()
, mixture = tune()
) %>%
set_engine("glmnet") %>%
set_mode("classification")
# set up the ranges for the tuning functions
elnet_grid <- grid_regular(
penalty()
, mixture()
, levels = 10
)
# set up the workflow: combine modeling spec with modeling recipe
set.seed(345)
elnet_wf <- workflow() %>%
add_model(tune_spec) %>%
add_recipe(mod_recipe)# set up the folds
d_train_cv <- rolling_origin(
d_train,
initial = 15,
assess = 3,
skip = 2,
cumulative = TRUE
)
# run our workflow from above across each fold
elnet_res <-
elnet_wf %>%
tune_grid(
resamples = d_train_cv
, grid = elnet_grid
, control = control_resamples(save_pred = T)
)# plot the metrics across tuning parameters
elnet_res %>%
collect_metrics() %>%
ggplot(aes(penalty, mean, color = mixture)) +
geom_point(size = 2) +
facet_wrap(~ .metric, scales = "free", nrow = 2) +
scale_x_log10(labels = scales::label_number()) +
scale_color_gradient(low = "gray90", high = "red") +
theme_classic()# select the best model based on AUC
best_elnet <- elnet_res %>%
# select_best("roc_auc")
select_best("accuracy")
# set up the workflow for the best model
final_wf <-
elnet_wf %>%
finalize_workflow(best_elnet)
# run the final best model on the training data and save
final_elnet <-
final_wf %>%
fit(data = d_train) ## Warning in lognet(xd, is.sparse, ix, jx, y, weights, offset, alpha, nobs, : one
## multinomial or binomial class has fewer than 8 observations; dangerous ground
# run the final fit workflow of the training and test data together
final_fit <-
final_wf %>%
last_fit(d_split) ## ! train/test split: preprocessor 1/1, model 1/1: one multinomial or binomial class has fewer...
# final metrics (accuracy and roc)
final_metrics <- final_fit %>%
collect_metrics(summarize = T); final_metrics# variable importance
final_var_imp <- final_elnet %>%
pull_workflow_fit() %>%
vi() %>%
slice_max(Importance, n = 10); final_var_imp## Warning: `pull_workflow_fit()` was deprecated in workflows 0.2.3.
## Please use `extract_fit_parsnip()` instead.
set.seed(5) # set a seed for randomly sampling 10 participants
dat4 <- read_csv(url(sprintf("%s/ESM-structure/blob/main/02-data/02-facet-wide/02-imputed/facet_wide_imp.csv?raw=true", wd))) %>%
filter(complete.cases(.)) %>% # drop missing obs
group_by(SID) %>%
filter(n() >= 30) %>% # keep only people with reasonable #'s of obs
ungroup() %>%
filter(SID %in% sample(unique(.$SID), 10)) %>% # sample 10 px
mutate(wave = 1) %>% # create a wave "grouping" variable
arrange(wave, SID, all_beeps) %>% # reorder the data
select(-Full_Date, -all_beeps) %>% # drop columns that aren't ID, group, or indicators
as.data.frame() # this is important! dynEGA won't work on tibbles## Rows: 23615 Columns: 18
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (2): SID, Full_Date
## dbl (16): agreeableness_Compassion, agreeableness_Respectfulness, agreeablen...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
# get numeric ID of the participant ID column
idcol <- which(colnames(dat4) == "SID")
gcol <- which(colnames(dat4) == "wave")
ega_ind <- dynEGA(
data = dat4
, n.embed = 4 # embedding dimension
, tau = 1 # offset for embedding, similar to lag 1
, delta = 4 # time between obs
, level = "individual" # we want individual-level models
, id = idcol # id column position
, group = gcol # group membership, in this case the wave
, use.derivatives = 1 # we want to use 1st order derivatives
, model = "glasso"
, algorithm = "louvain" # the clustering algorithm for structure
, corr = "pearson" # type of correlation
, ncores = 6 # number of cores
); ega_ind##
## Computing derivatives using GLLA...
## Estimating the dimensionality structure using EGA...
## Level: Individual (Intraindividual Structure)...
## done
## Number of Cases (individuals):
## [1] 10
## Summary statistics (number of factors/communities):
## Mean: 2.5
## Median: 3
## Min: 0
## Max: 4
First, let’s look at the derivatives. These are stored as a list for each participant:
# derivatives list
names(ega_ind$Derivatives$Estimates)## [1] "ID143" "ID148" "ID162" "ID168" "ID180" "ID186" "ID192" "ID38" "ID63"
## [10] "ID78"
# for one px
ega_ind$Derivatives$Estimates$ID143 %>% as_tibble()Or a large data frame:
ega_ind$Derivatives$EstimatesDF %>% as_tibble()Now let’s look at the EGA. These are also stored as a list for each participant.
names(ega_ind$dynEGA)## [1] "ID143" "ID148" "ID162" "ID168" "ID180" "ID186" "ID192" "ID38" "ID63"
## [10] "ID78"
names(ega_ind$dynEGA$ID143)## [1] "network" "wc" "n.dim" "cor.data"
## [5] "gamma" "lambda" "dim.variables"
Here’s the breakdown:
network = regularized partial correlation matrix.wc = cluster membership how igraph produces itn.dim = number of clustercor.data = zero-order correlations of the
derivativesmu = hyperparameter for glasso, 0 means it uses BIC for
model selectionlambda = regularization shrinkage parameterdim.variables = also cluster membership, but as a data
frameega_ind$dynEGA$ID143$network## agreeableness_Compassion.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 -0.09646158
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 -0.27236328
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.18753804
## openness_Intellectual.Curiosity.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.04193298
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.28647794
## extraversion_Assertiveness.Ord1 -0.07296645
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.02076857
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.15807089
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.19358344
## agreeableness_Trust.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.04193298
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.20654350
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.07619860
## extraversion_Energy.Level.Ord1 0.03280065
## extraversion_Sociability.Ord1 0.10078699
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.23756930
## openness_Creative.Imagination.Ord1 0.26449228
## openness_Intellectual.Curiosity.Ord1 0.00000000
## conscientiousness_Organization.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.20654350
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.07773032
## extraversion_Assertiveness.Ord1 -0.03120325
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 -0.15393608
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.14513046
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.09295943
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.28647794
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.07773032
## conscientiousness_Productiveness.Ord1 0.14513046
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 -0.02778201
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 -0.01266155
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.18373027
## openness_Creative.Imagination.Ord1 -0.05590719
## openness_Intellectual.Curiosity.Ord1 0.40289256
## extraversion_Assertiveness.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 -0.07296645
## agreeableness_Trust.Ord1 0.07619860
## conscientiousness_Organization.Ord1 -0.03120325
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.14236089
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 -0.10840522
## openness_Aesthetic.Sensitivity.Ord1 0.16720137
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## extraversion_Energy.Level.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.03280065
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.14236089
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.32906737
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.13128565
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## extraversion_Sociability.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.10078699
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 -0.02778201
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.32906737
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 -0.11916977
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## neuroticism_Anxiety.Ord1
## agreeableness_Compassion.Ord1 -0.09646158
## agreeableness_Respectfulness.Ord1 0.02076857
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.20650709
## neuroticism_Emotional.Volatility.Ord1 0.04973374
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.09460686
## openness_Intellectual.Curiosity.Ord1 0.00000000
## neuroticism_Depression.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 -0.15393608
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 -0.01266155
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 -0.11916977
## neuroticism_Anxiety.Ord1 0.20650709
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.22624339
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1
## agreeableness_Compassion.Ord1 -0.27236328
## agreeableness_Respectfulness.Ord1 0.15807089
## agreeableness_Trust.Ord1 0.00000000
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 0.00000000
## extraversion_Assertiveness.Ord1 -0.10840522
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.04973374
## neuroticism_Depression.Ord1 0.22624339
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 -0.14828005
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1
## agreeableness_Compassion.Ord1 0.00000000
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.23756930
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.09295943
## conscientiousness_Responsibility.Ord1 0.18373027
## extraversion_Assertiveness.Ord1 0.16720137
## extraversion_Energy.Level.Ord1 0.13128565
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.00000000
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 -0.14828005
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1
## agreeableness_Compassion.Ord1 0.18753804
## agreeableness_Respectfulness.Ord1 0.00000000
## agreeableness_Trust.Ord1 0.26449228
## conscientiousness_Organization.Ord1 0.00000000
## conscientiousness_Productiveness.Ord1 0.00000000
## conscientiousness_Responsibility.Ord1 -0.05590719
## extraversion_Assertiveness.Ord1 0.00000000
## extraversion_Energy.Level.Ord1 0.00000000
## extraversion_Sociability.Ord1 0.00000000
## neuroticism_Anxiety.Ord1 0.09460686
## neuroticism_Depression.Ord1 0.00000000
## neuroticism_Emotional.Volatility.Ord1 0.00000000
## openness_Aesthetic.Sensitivity.Ord1 0.00000000
## openness_Creative.Imagination.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1 0.00000000
## openness_Intellectual.Curiosity.Ord1
## agreeableness_Compassion.Ord1 0.0000000
## agreeableness_Respectfulness.Ord1 0.1935834
## agreeableness_Trust.Ord1 0.0000000
## conscientiousness_Organization.Ord1 0.0000000
## conscientiousness_Productiveness.Ord1 0.0000000
## conscientiousness_Responsibility.Ord1 0.4028926
## extraversion_Assertiveness.Ord1 0.0000000
## extraversion_Energy.Level.Ord1 0.0000000
## extraversion_Sociability.Ord1 0.0000000
## neuroticism_Anxiety.Ord1 0.0000000
## neuroticism_Depression.Ord1 0.0000000
## neuroticism_Emotional.Volatility.Ord1 0.0000000
## openness_Aesthetic.Sensitivity.Ord1 0.0000000
## openness_Creative.Imagination.Ord1 0.0000000
## openness_Intellectual.Curiosity.Ord1 0.0000000
ega_ind$dynEGA$ID143$wc## agreeableness_Compassion.Ord1 agreeableness_Respectfulness.Ord1
## 1 2
## agreeableness_Trust.Ord1 conscientiousness_Organization.Ord1
## 3 1
## conscientiousness_Productiveness.Ord1 conscientiousness_Responsibility.Ord1
## 2 2
## extraversion_Assertiveness.Ord1 extraversion_Energy.Level.Ord1
## 3 3
## extraversion_Sociability.Ord1 neuroticism_Anxiety.Ord1
## 3 1
## neuroticism_Depression.Ord1 neuroticism_Emotional.Volatility.Ord1
## 1 1
## openness_Aesthetic.Sensitivity.Ord1 openness_Creative.Imagination.Ord1
## 3 3
## openness_Intellectual.Curiosity.Ord1
## 2
ega_ind$dynEGA$ID143$n.dim## [1] 3
ega_ind$dynEGA$ID143$cor.data## agreeableness_Compassion.Ord1
## agreeableness_Compassion.Ord1 1.000000000
## agreeableness_Respectfulness.Ord1 -0.144917198
## agreeableness_Trust.Ord1 0.175232445
## conscientiousness_Organization.Ord1 0.008481247
## conscientiousness_Productiveness.Ord1 -0.090531113
## conscientiousness_Responsibility.Ord1 -0.046594591
## extraversion_Assertiveness.Ord1 0.237280217
## extraversion_Energy.Level.Ord1 0.004410670
## extraversion_Sociability.Ord1 0.092657858
## neuroticism_Anxiety.Ord1 -0.294995032
## neuroticism_Depression.Ord1 -0.187998551
## neuroticism_Emotional.Volatility.Ord1 -0.487960576
## openness_Aesthetic.Sensitivity.Ord1 -0.094449559
## openness_Creative.Imagination.Ord1 0.374580338
## openness_Intellectual.Curiosity.Ord1 0.097445847
## agreeableness_Respectfulness.Ord1
## agreeableness_Compassion.Ord1 -0.14491720
## agreeableness_Respectfulness.Ord1 1.00000000
## agreeableness_Trust.Ord1 0.22733578
## conscientiousness_Organization.Ord1 0.15188072
## conscientiousness_Productiveness.Ord1 0.11508995
## conscientiousness_Responsibility.Ord1 0.59763669
## extraversion_Assertiveness.Ord1 -0.26029253
## extraversion_Energy.Level.Ord1 -0.14374524
## extraversion_Sociability.Ord1 -0.01017949
## neuroticism_Anxiety.Ord1 0.21949054
## neuroticism_Depression.Ord1 0.12950398
## neuroticism_Emotional.Volatility.Ord1 0.35952234
## openness_Aesthetic.Sensitivity.Ord1 0.12089388
## openness_Creative.Imagination.Ord1 -0.17862193
## openness_Intellectual.Curiosity.Ord1 0.54388484
## agreeableness_Trust.Ord1
## agreeableness_Compassion.Ord1 0.1752324446
## agreeableness_Respectfulness.Ord1 0.2273357807
## agreeableness_Trust.Ord1 1.0000000000
## conscientiousness_Organization.Ord1 0.4129780505
## conscientiousness_Productiveness.Ord1 -0.0003581812
## conscientiousness_Responsibility.Ord1 0.0297829522
## extraversion_Assertiveness.Ord1 0.3330555363
## extraversion_Energy.Level.Ord1 0.3247680721
## extraversion_Sociability.Ord1 0.3357442349
## neuroticism_Anxiety.Ord1 0.1144625384
## neuroticism_Depression.Ord1 -0.1850295196
## neuroticism_Emotional.Volatility.Ord1 -0.1172334276
## openness_Aesthetic.Sensitivity.Ord1 0.4898881130
## openness_Creative.Imagination.Ord1 0.4634941426
## openness_Intellectual.Curiosity.Ord1 -0.0180078457
## conscientiousness_Organization.Ord1
## agreeableness_Compassion.Ord1 0.008481247
## agreeableness_Respectfulness.Ord1 0.151880718
## agreeableness_Trust.Ord1 0.412978051
## conscientiousness_Organization.Ord1 1.000000000
## conscientiousness_Productiveness.Ord1 0.097969594
## conscientiousness_Responsibility.Ord1 0.290368424
## extraversion_Assertiveness.Ord1 -0.157668146
## extraversion_Energy.Level.Ord1 0.063739422
## extraversion_Sociability.Ord1 0.115635672
## neuroticism_Anxiety.Ord1 -0.045553558
## neuroticism_Depression.Ord1 -0.350860934
## neuroticism_Emotional.Volatility.Ord1 -0.136406952
## openness_Aesthetic.Sensitivity.Ord1 0.265036100
## openness_Creative.Imagination.Ord1 0.148653742
## openness_Intellectual.Curiosity.Ord1 0.015304397
## conscientiousness_Productiveness.Ord1
## agreeableness_Compassion.Ord1 -0.0905311127
## agreeableness_Respectfulness.Ord1 0.1150899451
## agreeableness_Trust.Ord1 -0.0003581812
## conscientiousness_Organization.Ord1 0.0979695937
## conscientiousness_Productiveness.Ord1 1.0000000000
## conscientiousness_Responsibility.Ord1 0.3777149131
## extraversion_Assertiveness.Ord1 0.1723266074
## extraversion_Energy.Level.Ord1 0.1092529252
## extraversion_Sociability.Ord1 0.0066986477
## neuroticism_Anxiety.Ord1 0.0031348955
## neuroticism_Depression.Ord1 0.0720746796
## neuroticism_Emotional.Volatility.Ord1 -0.1159234988
## openness_Aesthetic.Sensitivity.Ord1 0.3205474808
## openness_Creative.Imagination.Ord1 0.0283903815
## openness_Intellectual.Curiosity.Ord1 0.2713788357
## conscientiousness_Responsibility.Ord1
## agreeableness_Compassion.Ord1 -0.04659459
## agreeableness_Respectfulness.Ord1 0.59763669
## agreeableness_Trust.Ord1 0.02978295
## conscientiousness_Organization.Ord1 0.29036842
## conscientiousness_Productiveness.Ord1 0.37771491
## conscientiousness_Responsibility.Ord1 1.00000000
## extraversion_Assertiveness.Ord1 -0.11824425
## extraversion_Energy.Level.Ord1 -0.06751410
## extraversion_Sociability.Ord1 -0.18150240
## neuroticism_Anxiety.Ord1 0.06733940
## neuroticism_Depression.Ord1 -0.19675725
## neuroticism_Emotional.Volatility.Ord1 -0.08387357
## openness_Aesthetic.Sensitivity.Ord1 0.41801298
## openness_Creative.Imagination.Ord1 -0.21722840
## openness_Intellectual.Curiosity.Ord1 0.68352130
## extraversion_Assertiveness.Ord1
## agreeableness_Compassion.Ord1 0.23728022
## agreeableness_Respectfulness.Ord1 -0.26029253
## agreeableness_Trust.Ord1 0.33305554
## conscientiousness_Organization.Ord1 -0.15766815
## conscientiousness_Productiveness.Ord1 0.17232661
## conscientiousness_Responsibility.Ord1 -0.11824425
## extraversion_Assertiveness.Ord1 1.00000000
## extraversion_Energy.Level.Ord1 0.38047327
## extraversion_Sociability.Ord1 0.10590085
## neuroticism_Anxiety.Ord1 0.01886838
## neuroticism_Depression.Ord1 0.09439041
## neuroticism_Emotional.Volatility.Ord1 -0.35793173
## openness_Aesthetic.Sensitivity.Ord1 0.42602702
## openness_Creative.Imagination.Ord1 0.18766602
## openness_Intellectual.Curiosity.Ord1 0.12597299
## extraversion_Energy.Level.Ord1
## agreeableness_Compassion.Ord1 0.00441067
## agreeableness_Respectfulness.Ord1 -0.14374524
## agreeableness_Trust.Ord1 0.32476807
## conscientiousness_Organization.Ord1 0.06373942
## conscientiousness_Productiveness.Ord1 0.10925293
## conscientiousness_Responsibility.Ord1 -0.06751410
## extraversion_Assertiveness.Ord1 0.38047327
## extraversion_Energy.Level.Ord1 1.00000000
## extraversion_Sociability.Ord1 0.53053567
## neuroticism_Anxiety.Ord1 0.01995421
## neuroticism_Depression.Ord1 -0.02092129
## neuroticism_Emotional.Volatility.Ord1 -0.17666250
## openness_Aesthetic.Sensitivity.Ord1 0.38957794
## openness_Creative.Imagination.Ord1 0.10358889
## openness_Intellectual.Curiosity.Ord1 -0.00652038
## extraversion_Sociability.Ord1
## agreeableness_Compassion.Ord1 0.092657858
## agreeableness_Respectfulness.Ord1 -0.010179487
## agreeableness_Trust.Ord1 0.335744235
## conscientiousness_Organization.Ord1 0.115635672
## conscientiousness_Productiveness.Ord1 0.006698648
## conscientiousness_Responsibility.Ord1 -0.181502397
## extraversion_Assertiveness.Ord1 0.105900846
## extraversion_Energy.Level.Ord1 0.530535673
## extraversion_Sociability.Ord1 1.000000000
## neuroticism_Anxiety.Ord1 -0.206975832
## neuroticism_Depression.Ord1 -0.324131535
## neuroticism_Emotional.Volatility.Ord1 -0.065618517
## openness_Aesthetic.Sensitivity.Ord1 0.143488176
## openness_Creative.Imagination.Ord1 0.147939076
## openness_Intellectual.Curiosity.Ord1 -0.147868651
## neuroticism_Anxiety.Ord1
## agreeableness_Compassion.Ord1 -0.294995032
## agreeableness_Respectfulness.Ord1 0.219490540
## agreeableness_Trust.Ord1 0.114462538
## conscientiousness_Organization.Ord1 -0.045553558
## conscientiousness_Productiveness.Ord1 0.003134896
## conscientiousness_Responsibility.Ord1 0.067339404
## extraversion_Assertiveness.Ord1 0.018868378
## extraversion_Energy.Level.Ord1 0.019954211
## extraversion_Sociability.Ord1 -0.206975832
## neuroticism_Anxiety.Ord1 1.000000000
## neuroticism_Depression.Ord1 0.414310299
## neuroticism_Emotional.Volatility.Ord1 0.316687604
## openness_Aesthetic.Sensitivity.Ord1 0.066432716
## openness_Creative.Imagination.Ord1 0.242009546
## openness_Intellectual.Curiosity.Ord1 0.148926682
## neuroticism_Depression.Ord1
## agreeableness_Compassion.Ord1 -0.18799855
## agreeableness_Respectfulness.Ord1 0.12950398
## agreeableness_Trust.Ord1 -0.18502952
## conscientiousness_Organization.Ord1 -0.35086093
## conscientiousness_Productiveness.Ord1 0.07207468
## conscientiousness_Responsibility.Ord1 -0.19675725
## extraversion_Assertiveness.Ord1 0.09439041
## extraversion_Energy.Level.Ord1 -0.02092129
## extraversion_Sociability.Ord1 -0.32413153
## neuroticism_Anxiety.Ord1 0.41431030
## neuroticism_Depression.Ord1 1.00000000
## neuroticism_Emotional.Volatility.Ord1 0.45415488
## openness_Aesthetic.Sensitivity.Ord1 -0.18675038
## openness_Creative.Imagination.Ord1 -0.06386812
## openness_Intellectual.Curiosity.Ord1 0.10632541
## neuroticism_Emotional.Volatility.Ord1
## agreeableness_Compassion.Ord1 -0.48796058
## agreeableness_Respectfulness.Ord1 0.35952234
## agreeableness_Trust.Ord1 -0.11723343
## conscientiousness_Organization.Ord1 -0.13640695
## conscientiousness_Productiveness.Ord1 -0.11592350
## conscientiousness_Responsibility.Ord1 -0.08387357
## extraversion_Assertiveness.Ord1 -0.35793173
## extraversion_Energy.Level.Ord1 -0.17666250
## extraversion_Sociability.Ord1 -0.06561852
## neuroticism_Anxiety.Ord1 0.31668760
## neuroticism_Depression.Ord1 0.45415488
## neuroticism_Emotional.Volatility.Ord1 1.00000000
## openness_Aesthetic.Sensitivity.Ord1 -0.37696342
## openness_Creative.Imagination.Ord1 -0.15339317
## openness_Intellectual.Curiosity.Ord1 0.06495692
## openness_Aesthetic.Sensitivity.Ord1
## agreeableness_Compassion.Ord1 -0.09444956
## agreeableness_Respectfulness.Ord1 0.12089388
## agreeableness_Trust.Ord1 0.48988811
## conscientiousness_Organization.Ord1 0.26503610
## conscientiousness_Productiveness.Ord1 0.32054748
## conscientiousness_Responsibility.Ord1 0.41801298
## extraversion_Assertiveness.Ord1 0.42602702
## extraversion_Energy.Level.Ord1 0.38957794
## extraversion_Sociability.Ord1 0.14348818
## neuroticism_Anxiety.Ord1 0.06643272
## neuroticism_Depression.Ord1 -0.18675038
## neuroticism_Emotional.Volatility.Ord1 -0.37696342
## openness_Aesthetic.Sensitivity.Ord1 1.00000000
## openness_Creative.Imagination.Ord1 0.13541568
## openness_Intellectual.Curiosity.Ord1 0.28415241
## openness_Creative.Imagination.Ord1
## agreeableness_Compassion.Ord1 0.37458034
## agreeableness_Respectfulness.Ord1 -0.17862193
## agreeableness_Trust.Ord1 0.46349414
## conscientiousness_Organization.Ord1 0.14865374
## conscientiousness_Productiveness.Ord1 0.02839038
## conscientiousness_Responsibility.Ord1 -0.21722840
## extraversion_Assertiveness.Ord1 0.18766602
## extraversion_Energy.Level.Ord1 0.10358889
## extraversion_Sociability.Ord1 0.14793908
## neuroticism_Anxiety.Ord1 0.24200955
## neuroticism_Depression.Ord1 -0.06386812
## neuroticism_Emotional.Volatility.Ord1 -0.15339317
## openness_Aesthetic.Sensitivity.Ord1 0.13541568
## openness_Creative.Imagination.Ord1 1.00000000
## openness_Intellectual.Curiosity.Ord1 -0.03077718
## openness_Intellectual.Curiosity.Ord1
## agreeableness_Compassion.Ord1 0.09744585
## agreeableness_Respectfulness.Ord1 0.54388484
## agreeableness_Trust.Ord1 -0.01800785
## conscientiousness_Organization.Ord1 0.01530440
## conscientiousness_Productiveness.Ord1 0.27137884
## conscientiousness_Responsibility.Ord1 0.68352130
## extraversion_Assertiveness.Ord1 0.12597299
## extraversion_Energy.Level.Ord1 -0.00652038
## extraversion_Sociability.Ord1 -0.14786865
## neuroticism_Anxiety.Ord1 0.14892668
## neuroticism_Depression.Ord1 0.10632541
## neuroticism_Emotional.Volatility.Ord1 0.06495692
## openness_Aesthetic.Sensitivity.Ord1 0.28415241
## openness_Creative.Imagination.Ord1 -0.03077718
## openness_Intellectual.Curiosity.Ord1 1.00000000
ega_ind$dynEGA$ID143$mu## NULL
ega_ind$dynEGA$ID143$lambda## [1] 0.1
ega_ind$dynEGA$ID143$dim.variablesLet’s plot it, shall we? To do this, we’ll use the
qgraph package and my own stylistic preferences.
# now let's wrangle the names of the labels
tnames <- tibble(old = rownames(ega_ind$dynEGA$ID143$network)
, new = paste0(rep(c("A", "C", "E", "N", "O"), each = 1), rep(1:3, times = 5)))
wmat <- ega_ind$dynEGA$ID143$network
colnames(wmat) <- tnames$new; rownames(wmat) <- tnames$new
# first, we need to make a list of the cluster membership
tmp <- ega_ind$dynEGA$ID143$dim.variables %>%
mutate(items = mapvalues(items, tnames$old, tnames$new)) %>%
group_by(dimension) %>%
nest() %>%
ungroup()
mem_list <- tmp$data; names(mem_list) <- tmp$dimension
cols <- RColorBrewer::brewer.pal(length(mem_list), "Set3")
g <- qgraph(
wmat
, color = cols # color based on cluster
, layout = "spring" # force directed algorithm
, border.width = 4 # width of the border around nodes
, vsize = 10 # size of the nodes
, label.font = 2 # make the font bold
, label.fill.vertical = 1 # make sure we use all our space for labels
, negDashed = T # dash negative edges
, edge.color = "black" # make edges black
, edge.labels = T # label the edges
)
plot(g)
title("ID143")We can also make this a more flexible function and do it for everyone!
tnames <- tibble(old = rownames(ega_ind$dynEGA$ID143$network)
, new = paste0(rep(c("A", "C", "E", "N", "O"), each = 1), rep(1:3, times = 5)))
ega_qgraph_fun <- function(obj, id){
# now let's wrangle the names of the labels
wmat <- obj$network
colnames(wmat) <- tnames$new; rownames(wmat) <- tnames$new
# first, we need to make a list of the cluster membership
tmp <- obj$dim.variables %>%
mutate(items = mapvalues(items, tnames$old, tnames$new)) %>%
group_by(dimension) %>%
nest() %>%
ungroup()
mem_list <- tmp$data; names(mem_list) <- tmp$dimension
cols <- RColorBrewer::brewer.pal(9, "Set3")[1:length(mem_list)]
g <- qgraph(
wmat
, color = cols # color based on cluster
, layout = "spring" # force directed algorithm
, border.width = 4 # width of the border around nodes
, vsize = 10 # size of the nodes
, label.font = 2 # make the font bold
, label.fill.vertical = 1 # make sure we use all our space for labels
, negDashed = T # dash negative edges
, edge.color = "black" # make edges black
, edge.labels = T # label the edges
, mar = c(4,4,5,4) # margins
)
title(id, line = 3)
}
par(mfrow = c(3,4))
tibble(
SID = names(ega_ind$dynEGA)
, network = ega_ind$dynEGA
) %>%
mutate(plot = map2(network, SID, ega_qgraph_fun))dat3 <- read_csv(url(sprintf("%s/ESM-structure/blob/main/02-data/02-facet-wide/02-imputed/facet_wide_imp.csv?raw=true", wd))) %>%
group_by(SID) %>%
mutate_at(vars(-Full_Date, -all_beeps), lst(lag = lag)) %>%
ungroup()## Rows: 23615 Columns: 18
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (2): SID, Full_Date
## dbl (16): agreeableness_Compassion, agreeableness_Respectfulness, agreeablen...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
Level 1:
\(Y_{it} = \beta_{0i} +
\epsilon_{it}\)
Level 2:
\(\beta_{0i} = \mu_{00} + u_{0i}\)
, where \(\beta_{0i}\) is the average value of \(Y\) for person \(i\) across all observations \(t\), \(\mu_{00}\) is the average value of \(Y\) across the full sample, and \(u_{0i}\) is the deviation from the average value of the sample for person \(i\) across all time points \(t\).
And the \(\tau\) matrix is summarized by a single cell, \(\tau_{00}^2\) and \(\sigma^2\) is the squared residuals, \(\epsilon_{it}\).
# run the model
mod0 <- lmer(agreeableness_Compassion ~ 1 + (1 | SID), data = dat3)
# get model term summaries
tidy(mod0, conf.int = T)# examine the Variance-Covariance matrix
VarCorr(mod0)## Groups Name Std.Dev.
## SID (Intercept) 0.24582
## Residual 0.80169
# Groups = SID = tau^2
# Residual = sigma^2The intraclass correlation captures the ratio of level 2 units (in this case person-means) to the total variance both across people and within each person:
\(\frac{\tau_{00}^2}{\tau_{00}^2 + \sigma^2}\)
vc <- VarCorr(mod0) %>% as.data.frame(); vcicc <- vc$vcov[1] / (vc$vcov[1] + vc$vcov[2]); icc## [1] 0.08594182
My hot take is that MLM’s should never be run without including either all estimates of level 2 units or a distribution of all of those estimates. We’ll do the latter here.
coef(mod0)$SID %>%
ggplot(aes(x = `(Intercept)`)) +
geom_histogram(aes(y = ..density..), fill = "lightgrey", color = "black") +
geom_density(color = "blue", size = 1) +
labs(x = "Agreeableness: Compassion Person-Mean"
, y = "Density"
, title = "Distribution of Level 2 Units") +
theme_classic() +
theme(plot.title = element_text(hjust = .5, face = "bold"))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Conditional model just means that we are adjusting the variance
decomposition by adding some covariate to the model. In this case, let’s
look at autoregresion, or using previous time point \(y\) to predict next time point \(y\).
Level 1:
\(Y_{it} = \beta_{0i} + \beta_{1i}*X_{it} +
\epsilon_{it}\)
Level 2:
\(\beta_{0i} = \mu_{00} +
u_{0i}\)
\(\beta_{0i} = \mu_{10} + u_{1i}\)
, where:
mod1 <- lmer(agreeableness_Compassion ~ 1 + agreeableness_Compassion_lag + ( 1 + agreeableness_Compassion_lag | SID)
, data = dat3); mod1## Linear mixed model fit by REML ['lmerMod']
## Formula: agreeableness_Compassion ~ 1 + agreeableness_Compassion_lag +
## (1 + agreeableness_Compassion_lag | SID)
## Data: dat3
## REML criterion at convergence: 12509.97
## Random effects:
## Groups Name Std.Dev. Corr
## SID (Intercept) 0.29114
## agreeableness_Compassion_lag 0.06579 -0.60
## Residual 0.80034
## Number of obs: 5126, groups: SID, 188
## Fixed Effects:
## (Intercept) agreeableness_Compassion_lag
## 3.35972 0.05038
td1 <- tidy(mod1, conf.int = T); td1There was a small carry-over association between previous and current time point compassion (\(\mu_{10}\) = 0.05, 95% CI = [0.02, 0.08]).
Here, we need to plot two random effects, the average level and teh average lagged association.
coef(mod1)$SID %>%
rownames_to_column("id") %>%
pivot_longer(
cols = -id
, names_to = "term"
, values_to = "est"
) %>%
mutate(term = mapvalues(term, c("(Intercept)", "agreeableness_Compassion_lag"), c("Person-Mean Compassion", "Person-Specific Lagged Association"))) %>%
ggplot(aes(x = est)) +
geom_histogram(aes(y = ..density..), fill = "lightgrey", color = "black") +
geom_density(color = "blue", size = 1) +
facet_grid(~term, scales = "free") +
labs(x = "Empirical Bayes Estimate"
, y = "Density"
, title = "Distribution of Level 2 Units") +
theme_classic() +
theme(plot.title = element_text(hjust = .5, face = "bold"))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Level 1:
\(Y_{it} = \beta_{0i} + \beta_{1i}*y_{it-1} +
\beta_{2i}*X_{it} + \epsilon_{it}\)
Level 2:
\(\beta_{0i} = \mu_{00} +
u_{0i}\)
\(\beta_{1i} = \mu_{10} +
u_{1i}\)
\(\beta_{2i} = \mu_{20} + u_{1i}\)
, where:
mod2 <- lmer(agreeableness_Compassion ~ 1 + agreeableness_Compassion_lag + extraversion_Sociability +
( 1 + agreeableness_Compassion_lag + extraversion_Sociability | SID)
, data = dat3); mod2## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge with max|grad| = 0.00955907 (tol = 0.002, component 1)
## Linear mixed model fit by REML ['lmerMod']
## Formula: agreeableness_Compassion ~ 1 + agreeableness_Compassion_lag +
## extraversion_Sociability + (1 + agreeableness_Compassion_lag +
## extraversion_Sociability | SID)
## Data: dat3
## REML criterion at convergence: 12365.16
## Random effects:
## Groups Name Std.Dev. Corr
## SID (Intercept) 0.14730
## agreeableness_Compassion_lag 0.06595 -0.69
## extraversion_Sociability 0.03845 0.99 -0.59
## Residual 0.78993
## Number of obs: 5126, groups: SID, 188
## Fixed Effects:
## (Intercept) agreeableness_Compassion_lag
## 2.97919 0.04667
## extraversion_Sociability
## 0.12424
## optimizer (nloptwrap) convergence code: 0 (OK) ; 0 optimizer warnings; 1 lme4 warnings
td2 <- tidy(mod2, conf.int = T); td2There was a concurrent association between sociability and compassion, even when accounting for previous compassion (\(\mu_{20}\) = 0.12, 95% CI [0.10, 0.15]). Moreover, even when accounting for concurrent sociability, the carry-over association of compassion remained ($_{10} = 0.05, 95% CI [0.02, 0.08]).
Here, we need to plot three random effects, the average level, the average lagged association, the sociability-compassion association.
coef(mod2)$SID %>%
rownames_to_column("id") %>%
pivot_longer(
cols = -id
, names_to = "term"
, values_to = "est"
) %>%
mutate(term = mapvalues(term, c("(Intercept)", "agreeableness_Compassion_lag", "extraversion_Sociability")
, c("Person-Mean Compassion", "Person-Specific Lagged Association", "Person-Specific\n Sociability-Compassion Association"))) %>%
ggplot(aes(x = est)) +
geom_histogram(aes(y = ..density..), fill = "lightgrey", color = "black") +
geom_density(color = "blue", size = 1) +
facet_grid(~term, scales = "free") +
labs(x = "Empirical Bayes Estimate"
, y = "Density"
, title = "Distribution of Level 2 Units") +
theme_classic() +
theme(plot.title = element_text(hjust = .5, face = "bold"))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Level 1:
\(Y_{it} = \beta_{0i} +
\beta_{1i}*(X_{it}-\bar{X}_{i}) + \epsilon_{it}\)
Level 2:
\(\beta_{0i} = \mu_{00} +
\mu_{01}*(\bar{X}_{i} - \bar{X}) + u_{0i}\)
\(\beta_{1i} = \mu_{10} +
\mu_{11}*(\bar{X}_{i} - \bar{X}) + u_{1i}\)
, where:
dat3a <- dat3 %>%
# keep only necessary variables
select(SID, all_beeps, agreeableness_Compassion, agreeableness_Compassion_lag, extraversion_Sociability, all_beeps) %>%
# group by person to get person-specific means
group_by(SID) %>%
# person-mean centered sociability -- used in model
mutate(extraversion_Sociability_c = extraversion_Sociability - mean(extraversion_Sociability, na.rm = T)
# person average sociability -- not used in model
, extraversion_Sociability_m = mean(extraversion_Sociability, na.rm = T)) %>%
ungroup() %>%
# grand mean centered person means -- used in model
mutate(extraversion_Sociability_gmc = extraversion_Sociability_m - mean(extraversion_Sociability_m))
# run the model
mod3 <- lmer(agreeableness_Compassion ~ 1 + extraversion_Sociability_c + extraversion_Sociability_gmc + extraversion_Sociability_c:extraversion_Sociability_gmc +
(1 + extraversion_Sociability_c | SID), data = dat3a); mod3## Linear mixed model fit by REML ['lmerMod']
## Formula:
## agreeableness_Compassion ~ 1 + extraversion_Sociability_c + extraversion_Sociability_gmc +
## extraversion_Sociability_c:extraversion_Sociability_gmc +
## (1 + extraversion_Sociability_c | SID)
## Data: dat3a
## REML criterion at convergence: 20825.05
## Random effects:
## Groups Name Std.Dev. Corr
## SID (Intercept) 0.20193
## extraversion_Sociability_c 0.02567 0.44
## Residual 0.79106
## Number of obs: 8673, groups: SID, 199
## Fixed Effects:
## (Intercept)
## 3.50554
## extraversion_Sociability_c
## 0.11146
## extraversion_Sociability_gmc
## 0.36405
## extraversion_Sociability_c:extraversion_Sociability_gmc
## 0.06265
td3 <- tidy(mod3, conf.int = T); td3Higher sociability than usual for an individual is associated with more compassion, on average (\(\mu_{10}\) = 0.11, 95% CI [0.10, 0.13]). People with higher sociability, on average, were also more compassionate (\(\mu_{01}\) = 0.36, 95% CI [0.28, 0.45]). Finally, there was interaction between average sociability and deviations of sociability (\(\mu_{11}\) = 0.06, 95% CI [0.02, 0.10]), such that for individuals who were higher in sociability than others, they were even more compassionate when they were more sociable than usual relative to individuals lower in sociability than others.
Here, we need to plot two random effects, the average level and the association between deviations from person-means in sociability and deviations in compassion.
coef(mod3)$SID %>%
rownames_to_column("id") %>%
select(-extraversion_Sociability_gmc, -`extraversion_Sociability_c:extraversion_Sociability_gmc`) %>%
pivot_longer(
cols = -id
, names_to = "term"
, values_to = "est"
) %>%
mutate(term = mapvalues(term, c("(Intercept)", "extraversion_Sociability_c"), c("Person-Mean Compassion", "Person-Specific Sociability-Compassion Association"))) %>%
ggplot(aes(x = est)) +
geom_histogram(aes(y = ..density..), fill = "lightgrey", color = "black") +
geom_density(color = "blue", size = 1) +
facet_grid(~term, scales = "free") +
labs(x = "Empirical Bayes Estimate"
, y = "Density"
, title = "Distribution of Level 2 Units") +
theme_classic() +
theme(plot.title = element_text(hjust = .5, face = "bold"))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
These data come from the National Longitudinal Studies of Youth, Children and Young Adults Sample and were used in Bollich, Beck, Hill, and Jackson (2021) to estimate trajectories of four individual difference characteristics depending on whether adolescents had contact with the criminal justice system or not.
load(url("https://github.com/emoriebeck/R-tutorials/blob/master/11-ggplot-p3-mlm/data/sample.RData?raw=true"))
sample_datAt its simplest, a growth model is just a basic MLM with a
time-varying covariate (where the time-varying covariate is itself
time).
Level 1:
\(Y_{it} = \beta_{0i} + \beta_{1i}*time_{it} +
\epsilon_{it}\)
Level 2:
\(\beta_{0i} = \mu_{00} +
u_{0i}\)
\(\beta_{1i} = \mu_{10} + u_{1i}\)
, where:
mod4 <- lmer(CESD ~ 1 + age0 + ( 1 + age0 | PROC_CID), data = sample_dat); mod4## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, :
## Model failed to converge with max|grad| = 0.00354122 (tol = 0.002, component 1)
## Linear mixed model fit by REML ['lmerMod']
## Formula: CESD ~ 1 + age0 + (1 + age0 | PROC_CID)
## Data: sample_dat
## REML criterion at convergence: 3436.366
## Random effects:
## Groups Name Std.Dev. Corr
## PROC_CID (Intercept) 0.35986
## age0 0.04852 -0.50
## Residual 0.45018
## Number of obs: 2084, groups: PROC_CID, 924
## Fixed Effects:
## (Intercept) age0
## 0.702309 0.007357
## optimizer (nloptwrap) convergence code: 0 (OK) ; 0 optimizer warnings; 1 lme4 warnings
td4 <- tidy(mod4, conf.int = T); td4Overall, there was no significant change in Sensation Seeking across adolescence (\(\mu_{10}\) = 0.007, 95% CI [-0.0003, 0.02]).
Here, we need to plot two random effects, the average level at age 14 and the slope.
coef(mod4)$PROC_CID %>%
rownames_to_column("id") %>%
pivot_longer(
cols = -id
, names_to = "term"
, values_to = "est"
) %>%
mutate(term = mapvalues(term, c("(Intercept)", "age0")
, c("CESD at Age 14", "Person-Specific Slope"))) %>%
ggplot(aes(x = est)) +
geom_histogram(aes(y = ..density..), fill = "lightgrey", color = "black") +
geom_density(color = "blue", size = 1) +
facet_grid(~term, scales = "free") +
labs(x = "Empirical Bayes Estimate"
, y = "Density"
, title = "Distribution of Level 2 Units") +
theme_classic() +
theme(plot.title = element_text(hjust = .5, face = "bold"))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
At its most basic form, a mega-analysis is just a basic multilevel model with a Level 1 covariate. The difference is that it’s no longer observations across time nested within people. Instead its people nested within samples with samples as the grouping variable.
Level 1:
\(Y_{is} = \beta_{0s} + \beta_{2s}*X_{is} +
\epsilon_{is}\)
Level 2:
\(\beta_{0i} = \gamma_{00} +
u_{0i}\)
\(\beta_{1s} = \gamma_{10} +
u_{1s}\)
, where:
These data come from a yet-unpublished project examining 8 methods for synthesizing data via individual-participants meta-analysis, including meta-analysis. The data come from many samples, but all information on those samples has been scrubbed from the data we’ll be using and it will only be a relatively small sub-sample of the population (500 from each sample). Specifically, this data set examines the association bewteen Conscientiousness and episodic memory across 10 samples.
load(url("https://github.com/emoriebeck/R-tutorials/blob/master/99_archive/sample-mega-analysis.RData?raw=true"))
dmod5 <- lmer(o_value ~ 1 + p_value + ( 1 + p_value | study), data = d); mod5## Linear mixed model fit by REML ['lmerMod']
## Formula: o_value ~ 1 + p_value + (1 + p_value | study)
## Data: d
## REML criterion at convergence: 21623.18
## Random effects:
## Groups Name Std.Dev. Corr
## study (Intercept) 2.119
## p_value 0.120 -0.68
## Residual 2.087
## Number of obs: 5000, groups: study, 10
## Fixed Effects:
## (Intercept) p_value
## 5.1446 0.1014
td5 <- tidy(mod5, conf.int = T); td5Overall, there was a significant association between Conscientiousness and Episodic Memory across samples (\(\gammau_{10}\) = 0.10, 95% CI [0.02, 0.18]).
Rather than distributions, we are going to look at forest plots of the intercepts and personality-outcome associations because this is more typical in meta/mega-analysis.
fp_dat <- coef(mod5)$study %>%
data.frame() %>%
rownames_to_column("study") %>%
mutate(term = "estimate") %>%
full_join(
parameters::standard_error(mod5, effects = "random")$study %>%
data.frame() %>%
rownames_to_column("study") %>%
mutate(term = "SE")) %>%
rename(Intercept = X.Intercept.) %>%
# select(study, term, , p_value) %>%
pivot_longer(c(-study, -term), names_to = "names", values_to = "estimate") %>%
pivot_wider(names_from = "term", values_from = "estimate") %>%
rename(term = names) %>%
mutate(conf.low = estimate - 2*SE, conf.high = estimate + 2*SE,
term = ifelse(grepl("p_value.", term), str_replace_all(term, "p_value.", "p_value:"), term)) %>%
full_join(
td5 %>%
filter(effect == "fixed") %>%
select(term, estimate, conf.low, conf.high) %>%
mutate(study = "Overall", term = str_replace(term, "\\(Intercept\\)", "Intercept"))
)## Joining, by = c("study", "X.Intercept.", "p_value", "term")
## Joining, by = c("study", "term", "estimate", "conf.low", "conf.high")
## arrange by effect size
std_levs <- (fp_dat %>%
filter(study != "Overall" & term == "p_value") %>%
arrange(estimate))$study
fp_dat %>%
filter(term == "p_value") %>%
mutate(study = factor(study, c("Overall", std_levs))) %>%
ggplot(aes(x = study, y = estimate)) +
geom_errorbar(aes(ymin = conf.low, ymax = conf.high)
, position = "dodge"
, width = .1) +
geom_hline(aes(yintercept = 0), linetype = "dashed", size = .7) +
geom_point() +
coord_flip() +
theme_classic() Honestly, this isn’t a super-satisfactory forest plot, but much better examples can be found at https://github.com/emoriebeck/data-synthesis-tutorial and seen on https://emoriebeck.shinyapps.io/data-synthesis-tutorial.
id <- rep(1, 16)
x1 <- c(3, 2, 3, 3, 2, 5, 4, 5, 2, 4, 4, 3, 4, 2, 2, 4)
x2 <- c(3, 2, 1, 4, 3, 4, 3, 2, 3, 2, 3, 2, 4, 2, 1, 3)
x3 <- c(4, 1, 1, 4, 3, 1, 2, 4, 3, 3, 2, 3, 1, 2, 1, 0)
x4 <- c(3, 4, 3, 3, 3, 4, 1, 4, 2, 1, 4, 2, 4, 4, 2, 4)
x5 <- c(3, 2, 4, 3, 3, 1, 2, 3, 3, 3, 0, 2, 4, 3, 2, 4)
x <- cbind(x1, x2, x3, x4, x5)
r <- round(apply(x, 2, function(i) glla(i, n.embed = 5, tau = 1, delta = 4, order = 1)[,2]), 2)
g <- qgraph(cor_auto(r)
, layout = "spring"
, graph = "glasso"
, sampleSize = 100
, color = c("#302ef9", "#ec7d32", "#ffbf00", "#00b050", "#70309f")
, vsize = 15
, border.width = 4
# , labels = c("x_1*", "delta x1*", "delta x1*", "delta x1*", "delta x1*")
, label.color = "white"
, label.font = 2
, label.fill.vertical = 1
, edge.color = "black")g$graphAttributes$Edges$lty[g$Edgelist$weight < 0] <- 2
# png(filename = "~/Downloads/plot.png", width = 1000, height = 1000)
plot(g)# dev.off()
pr <- getWmat(g)
x <- as.data.frame(cbind(id, x1, x2, x3, x4, x5))
dx <- dynEGA(x, n.embed = 5, level = "individual", model = "glasso", id = 1, delta = 4, order = 1)##
## Computing derivatives using GLLA...
## Estimating the dimensionality structure using EGA...
## Level: Individual (Intraindividual Structure)...
## done